{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lambola.IDL.Pretty
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Pretty print.
-- 
--------------------------------------------------------------------------------

module Lambola.IDL.Pretty
 
  where

import Lambola.IDL.Syntax
import Lambola.IDL.PrettyIDLExpr

import Text.PrettyExprHPJ                       -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ            -- package: pretty


pretty :: [Definition] -> Doc
pretty = specification

prettyIO :: [Definition] -> IO ()
prettyIO = putStrLn . render . pretty

-- | (1) specification
--
specification :: [Definition] -> Doc
specification = vcat . map definition

-- | (2) definition
--
definition :: Definition -> Doc
definition def = fn def <> semi
  where
    fn (TypedefDcl ty ds)                     = 
        text "typedef" <+> typeSpec ty <+> declarators ds

    fn (TypeDcl ty)                           = typeSpec ty
    fn (AttrDcl access ty ds)                 = attrDcl access ty ds
    fn (ForwardDcl ident)                     = interfaceHeader ident []
    fn (InterfaceDcl ident inspec body)       =
        interfaceHeader ident inspec <+> braces (specification body)

    fn (ConstDcl ty ident expr)               = constDcl ty ident expr
    fn (Module ident defs)                    = idlmodule ident defs

    fn (ExceptDcl ident mems)                 = exceptDcl ident mems

    fn (OpDcl oattr ty ident dcls optr optc)  = 
        opDcl oattr ty ident dcls optr optc



-- | (3) module
--
idlmodule :: Identifier -> [Definition] -> Doc
idlmodule ident defs = 
    text "module" <+> text ident <+> nest 2 (braces $ specification defs)

interfaceBody :: [Definition] -> Doc
interfaceBody defs = vcat $ map definition defs

-- | (7) interface header
--
interfaceHeader :: Identifier -> [ScopedName] -> Doc
interfaceHeader ident [] = text "interface" <+> text ident
interfaceHeader ident ss = 
    text "interface" <+> text ident <+> inheritanceSpec ss


-- | (10) inheritance spec
--
inheritanceSpec :: [ScopedName] -> Doc
inheritanceSpec ss = colon <+> commaSep (map scopedName ss)


-- | (11) scoped name
--
scopedName :: ScopedName -> Doc 
scopedName (ScopedName [] ident) = text ident
scopedName (ScopedName ss ident) = 
    sepEndBy (map text ss) (text "::") <+> text ident


-- | (12) const dcl
--
constDcl :: TypeSpec -> Identifier -> ConstExp -> Doc
constDcl ty ident expr = 
    text "const" <+> typeSpec ty <+> text ident 
                 <+> char '='    <+> constExp expr


-- | (14) const exp
--
constExp :: ConstExp -> Doc
constExp = unparse . exprDoc


exprDoc :: ConstExp -> DocE
exprDoc (UnaryExp op expr)      = unaryDocE op (exprDoc expr)
exprDoc (BinaryExp op e1 e2)    = binDocE op (exprDoc e1) (exprDoc e2) 
exprDoc (NamedExp s)            = Atom $ scopedName s
exprDoc (IntegerLit i)          = Atom $ integer i
exprDoc (StringLit s)           = Atom $ stringLiteral s
exprDoc (CharLit c)             = Atom $ charLiteral c
exprDoc (FloatingPtLit d)       = Atom $ double d
exprDoc (BooleanLit b)          = Atom $ booleanLiteral b


unaryDocE :: UnaryOp -> DocE -> DocE
unaryDocE UNARY_NEGATE  = negateU
unaryDocE UNARY_PLUS    = plusU
unaryDocE UNARY_BNOT    = bitwiseNotU

binDocE :: BinaryOp -> DocE -> DocE -> DocE
binDocE BIN_OR      = bitwiseOrB 
binDocE BIN_XOR     = bitwiseXorB 
binDocE BIN_AND     = bitwiseAndB
binDocE BIN_SHIFTR  = rightShiftB
binDocE BIN_SHIFTL  = leftShiftB
binDocE BIN_PLUS    = addB
binDocE BIN_MINUS   = subtractB 
binDocE BIN_MULT    = multiplyB
binDocE BIN_DIV     = divideB
binDocE BIN_MOD     = moduloB



-- | (25) boolean literal 
--
booleanLiteral :: Bool -> Doc
booleanLiteral True   = text "TRUE"
booleanLiteral False  = text "FALSE"


-- | (29) type spec
--
typeSpec :: TypeSpec -> Doc
typeSpec (TyNamed sname)            = scopedName sname
typeSpec (TyVoid)                   = text "void"
typeSpec (TyBoolean)                = text "boolean"
typeSpec (TyInt spec)               = integerType spec
typeSpec (TyFloat spec)             = floatingPtType spec 
typeSpec (TyChar)                   = text "char"
typeSpec (TyString opt)             = stringType opt
typeSpec (TyOctet)                  = text "octet"
typeSpec (TyAny)                    = text "any"
typeSpec (TyStruct ident mems)      = structType ident mems
typeSpec (TyUnion ident ty uns)     = unionType ident ty uns
typeSpec (TyEnum ident es)          = enumType ident es
typeSpec (TySequence ty opt)        = sequenceType ty opt


-- | (34) declarators
--
declarators :: [Declarator] -> Doc
declarators = commaSep . map declarator


-- | (35) declarator
--
declarator :: Declarator -> Doc
declarator (SimpleDeclarator ident)     = text ident
declarator (ArrayDeclarator ident ixs)  = 
    text ident <> hcat (map (\i -> brackets (constExp i)) ixs)

-- | (38) floating pt type
--
floatingPtType :: FloatSpecifier -> Doc
floatingPtType (FLOAT)                = text "float"
floatingPtType (DOUBLE)               = text "double"


-- | (39) integer type
--
integerType :: IntSpecifier -> Doc
integerType (SIGNED_LONG_INT)        = text "signed"   <+> text "long"
integerType (SIGNED_SHORT_INT)       = text "signed"   <+> text "short"
integerType (UNSIGNED_LONG_INT)      = text "unsigned" <+> text "long"
integerType (UNSIGNED_SHORT_INT)     = text "unsigned" <+> text "short"


-- (46) char type - folded into type spec

-- (47) boolean type - folded into type spec

-- (48) octet type - folded into type spec

-- (49) any type - folded into type spec

-- | (50) struct type 
--
structType :: Identifier -> [Member] -> Doc
structType ident mems = 
    text "struct" <+> text ident <+> braces (memberList mems)


-- | (51) member list
--
memberList :: [Member] -> Doc
memberList = vcat . map member 


-- | (52) member
--
member :: Member -> Doc
member (Member ty ds) = typeSpec ty <+> declarators ds <+> semi

-- | (53) union type
--
unionType :: Identifier -> TypeSpec -> [UnionCase] -> Doc
unionType ident ty body = 
    text "union" <+> text ident <+> text "switch" <+> parens (typeSpec ty)
                 <+> braces (switchBody body)

-- | (55) switch body
--
switchBody :: [UnionCase] -> Doc
switchBody = vcat . map unionCase


-- | (56) case
--
unionCase :: UnionCase -> Doc
unionCase (UnionCase labels eltspec) = 
    hcat (map caseLabel labels) <+> elementSpec eltspec

-- | (57) case label
--
caseLabel :: CaseLabel -> Doc
caseLabel (CaseOf expr)         = text "case" <+> constExp expr <> char ':'
caseLabel (CaseDefault)         = text "default" <> char ':'

-- | (58) element spec
--
elementSpec :: ElementSpec -> Doc
elementSpec (ElementSpec ty decl) = typeSpec ty <+> declarator decl

-- | (59) element type
--
enumType :: Identifier -> [Identifier] -> Doc
enumType ident es = 
    text "enum" <+> text ident <+> braces (commaSep $ map text es)


-- | (61) sequence type
--
sequenceType :: TypeSpec -> Maybe ConstExp -> Doc
sequenceType ty Nothing    = text "sequence" <> angles (typeSpec ty) 
sequenceType ty (Just len) = 
    text "sequence" <> angles (typeSpec ty <> comma <> constExp len) 



-- | (62) string type
--
stringType :: Maybe ConstExp -> Doc
stringType (Nothing) = text "string"
stringType (Just i)  = text "string" <> angles (constExp i)


-- | (65) attr dcl
--
attrDcl :: AccessSpec -> TypeSpec -> [Declarator] -> Doc
attrDcl READONLY ty ds = text "readonly" <+> attrDcl1 ty ds
attrDcl _        ty ds = attrDcl1 ty ds

attrDcl1 :: TypeSpec -> [Declarator] -> Doc
attrDcl1 ty ds = text "attribute" <+> typeSpec ty <+> declarators ds
 

-- | (66) except dcl
--
exceptDcl :: Identifier -> [Member] -> Doc
exceptDcl ident mems = 
    text "exception" <+> text ident <+> braces (vcat $ map member mems)


-- (67) op dcl
-- 
opDcl :: OpAttribute 
      -> TypeSpec 
      -> Identifier
      -> [ParamDcl] 
      -> Maybe RaisesExpr 
      -> Maybe ContextExpr 
      -> Doc
opDcl attrib ty ident dcls opt_raises opt_context = 
    let rest = opDcl1 ty ident dcls opt_raises opt_context
    in case attrib of
        ONEWAY -> opAttribute <+> rest
        _      -> rest

opDcl1 :: TypeSpec 
       -> Identifier
       -> [ParamDcl] 
       -> Maybe RaisesExpr 
       -> Maybe ContextExpr 
       -> Doc
opDcl1 ty ident dcls opt_raises opt_context = 
    typeSpec ty <+> text ident <+> parameterDcls dcls 
                <> maybeSpaced (fmap raisesExpr opt_raises)
                <> maybeSpaced (fmap contextExpr opt_context)


-- | (68) op attribute
--
opAttribute :: Doc
opAttribute = text "oneway"


-- | (70) parameter dcls
--
parameterDcls :: [ParamDcl] -> Doc
parameterDcls [] = text "()"
parameterDcls ds = parens $ commaSep $ map paramDcl ds

-- | (71) param dcl
--
paramDcl :: ParamDcl -> Doc
paramDcl (ParamDcl pattr ty decl) = 
    paramAttribute pattr <+> typeSpec ty <+> declarator decl

-- | (72) param attribute
--
paramAttribute :: ParamAttribute -> Doc
paramAttribute (IN)     = text "in"
paramAttribute (OUT)    = text "out"
paramAttribute (INOUT)  = text "inout"


-- | (73) raises expr 
-- 
raisesExpr :: [ScopedName] -> Doc
raisesExpr ss = text "raises" <+> parens (commaSep $ map scopedName ss)


-- | (74) context expr 
-- 
contextExpr :: [String] -> Doc
contextExpr ss = text "context" <+> parens (commaSep $ map stringLiteral ss)


-- (75) param type spec - folded into type spec

--------------------------------------------------------------------------------
-- Helpers

stringLiteral :: String -> Doc
stringLiteral s = text $ '"' : s ++ ['"']

charLiteral :: Char -> Doc
charLiteral c = text $ [ '\'', c, '\'']

angles :: Doc -> Doc
angles p       = char '<' <> p <> char '>'


catWith :: [Doc] -> Doc -> Doc
catWith ds sp = hcat $ punctuate sp ds

sepWith :: [Doc] -> Doc -> Doc
sepWith ds sp = hsep $ punctuate sp ds

maybeSpaced :: Maybe Doc -> Doc
maybeSpaced (Just d)  = empty <+> d
maybeSpaced (Nothing) = empty


commaCat :: [Doc] -> Doc
commaCat = catWith `flip` comma

commaSep :: [Doc] -> Doc
commaSep = sepWith `flip` comma


sepEndBy :: [Doc] -> Doc -> Doc
sepEndBy ds sp = hsep $ map (<> sp) ds
